home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TSR / PPTSR10 / FUNFUNK.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-12  |  4KB  |  189 lines
  1. (*
  2. Program  : funfunk.pas
  3. Function : Example TSR program. Screen saver.
  4. From     : DOS International, June 1992
  5. Modified : P.Peters
  6. Date     : June 1992
  7. *)
  8. program funfunk;
  9. {$m $1000,0,0}
  10. {$r-,s-,x+}
  11.  
  12. uses
  13.   crt,tsr;
  14.  
  15. type
  16.   buffer = array[1..4000] of byte;
  17.  
  18. const
  19.   idcode  = $c0;
  20.   smileys : word = 100;
  21.   wait    : word = 1;
  22.  
  23. var
  24.   scrbuf  : buffer;
  25.  
  26. procedure smile; far;
  27. var
  28.   scrmem : ^buffer;
  29.   smiley : word;
  30.   x      : word;
  31. begin
  32.   case mem[$40:$49] of
  33.     3 : scrmem := ptr($b800,0);
  34.     7 : scrmem := ptr($b000,0);
  35.     else
  36.       for x := 1 to 8 do begin
  37.         sound(x*1000);
  38.         delay(20);
  39.         nosound;
  40.         delay(20);
  41.       end;
  42.       exit;
  43.    end;
  44.    move(scrmem^,scrbuf,sizeof(scrbuf));
  45.    repeat
  46.      if (random(2000) > 2000-smileys) then
  47.        smiley := (random(14)+1) shl 8 + 1
  48.      else
  49.        smiley := 0;
  50.      move(smiley,scrmem^[1+random(2000)*2],2);
  51.      delay(wait);
  52.    until keypressed;
  53.    repeat
  54.      readkey;
  55.    until not keypressed;
  56.    move(scrbuf,scrmem^,sizeof(scrbuf));
  57. end;
  58.  
  59. (* a user defined int 2f procedure is called when int 2f executed
  60.  * and al >= 2. ah is cleared before calling this procedure
  61.  *)
  62. procedure hook2f; far; assembler;
  63. label
  64.   tst3, tst4, fin;
  65. asm
  66.   cmp   ax,2  {set delay}
  67.   jne   tst3
  68.   mov   wait,cx
  69. tst3:
  70.   cmp   ax,3  {set # smileys}
  71.   jne   tst4
  72.   mov   smileys,cx
  73. tst4:
  74.   cmp   ax,4  {read delay and # smileys}
  75.   jne   fin
  76.   mov   bx,wait
  77.   mov   cx,smileys
  78. fin:
  79. end;
  80.  
  81. var
  82.   num : word;
  83.  
  84. procedure paramcheck; far;
  85. var
  86.   s : string;
  87.   i : byte;
  88.  
  89.   function makenum( max : integer ) : boolean;
  90.   var
  91.     code : integer;
  92.   begin
  93.     delete(s,1,1);
  94.     val(s,num,code);
  95.     makenum := (code=0) and (num <= max);
  96.   end;
  97.  
  98.   procedure senddelay;
  99.   begin
  100.     if makenum(25) then begin
  101.       if tsrloaded then
  102.         asm
  103.           mov   cx,num
  104.           mov   ax,idcode shl 8 + 2
  105.           int   2fh
  106.         end
  107.       else
  108.         wait := num;
  109.       writeln('Delay : ',num);
  110.     end else
  111.       writeln('Invalid parameter : ',s);
  112.   end;
  113.  
  114.   procedure sendsmileys;
  115.   begin
  116.     if makenum(2000) then begin
  117.       if tsrloaded then
  118.         asm
  119.           mov   cx,num
  120.           mov   ax,idcode shl 8 + 3
  121.           int   2fh
  122.         end
  123.       else
  124.        smileys := num;
  125.       writeln(num,' Smileys');
  126.     end else
  127.       writeln('Invalid parameter : ',s);
  128.   end;
  129.  
  130.   procedure getinfo;
  131.   begin
  132.     if tsrloaded then begin
  133.       asm
  134.         mov   ax,idcode shl 8 + 4
  135.         int   2fh
  136.         mov   wait,bx
  137.         mov   smileys,cx
  138.       end;
  139.       writeln('Info from Tsr');
  140.       writeln('  Delay   : ',wait);
  141.       writeln('  Smileys : ',smileys);
  142.     end else begin
  143.       writeln('Tsr receiver not installed.');
  144.       halt;
  145.     end;
  146.   end;
  147.  
  148.   procedure writeopt;
  149.   begin
  150.     writeln('Usage:');
  151.     writeln('  FunFunk [Option]');
  152.     writeln('Options:');
  153.     writeln('  /u          Remove Tsr');
  154.     writeln('  /d0..25     Delay');
  155.     writeln('  /s0..2000   Number of smileys');
  156.     writeln('  /i          Info from Tsr');
  157.     halt;
  158.   end;
  159.  
  160. begin {paramcheck}
  161.   if paramcount > 0 then
  162.     for i := 1 to paramcount do begin
  163.       s := paramstr(i);
  164.       s[1] := upcase(s[1]);
  165.       if s[1] = '/' then begin (* switch *)
  166.         delete(s,1,1);
  167.         s[1] := upcase(s[1]);
  168.         case s[1] of
  169.           'D' : senddelay;
  170.           'S' : sendsmileys;
  171.           'I' : getinfo;
  172.           '?' : writeopt;
  173.           else begin
  174.             writeln('Invalid switch : ',s);
  175.             writeopt;
  176.           end;
  177.         end;
  178.       end else begin (* no switch *)
  179.         writeln('Invalid parameter : ',s);
  180.         writeopt;
  181.       end;
  182.     end;
  183. end;
  184.  
  185. begin
  186.   writeln('FunFunk Tsr-Testprogram'^m^j);
  187.   tsrinstall('[Alt][F10]',$7100,idcode,smile,hook2f,paramcheck);
  188. end.
  189.